home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 21
/
Cream of the Crop 21 (Terry Blount) (October 1996).iso
/
os2
/
e33el2.zip
/
emacs
/
19.33
/
lisp
/
viper-util.el
< prev
next >
Wrap
Lisp/Scheme
|
1996-08-04
|
44KB
|
1,253 lines
;;; viper-util.el --- Utilities used by viper.el
;; Copyright (C) 1994, 1995, 1996 Free Software Foundation, Inc.
;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;; Code
(require 'ring)
;; Compiler pacifier
(defvar vip-overriding-map)
(defvar pm-color-alist)
(defvar zmacs-region-stays)
(defvar vip-search-face)
(defvar vip-minibuffer-current-face)
(defvar vip-minibuffer-insert-face)
(defvar vip-minibuffer-vi-face)
(defvar vip-minibuffer-emacs-face)
(defvar vip-replace-overlay-face)
(defvar vip-minibuffer-overlay)
(defvar vip-replace-overlay)
(defvar vip-search-overlay)
(defvar vip-replace-overlay-cursor-color)
(defvar vip-intermediate-command)
(defvar vip-use-replace-region-delimiters)
(defvar vip-fast-keyseq-timeout)
(defvar vip-related-files-and-buffers-ring)
;; end compiler pacifier
;; Is it XEmacs?
(defconst vip-xemacs-p (string-match "\\(Lucid\\|XEmacs\\)" emacs-version))
;; Is it Emacs?
(defconst vip-emacs-p (not vip-xemacs-p))
;; Tell whether we are running as a window application or on a TTY
(defsubst vip-device-type ()
(if vip-emacs-p
window-system
(device-type (selected-device))))
;; in XEmacs: device-type is tty on tty and stream in batch.
(defun vip-window-display-p ()
(and (vip-device-type) (not (memq (vip-device-type) '(tty stream)))))
(defvar vip-ms-style-os-p (memq system-type '(ms-dos windows-nt windows-95))
"Tells if Emacs is running under an MS-style OS: ms-dos, windows-nt, W95.")
(defvar vip-vms-os-p (memq system-type '(vax-vms axp-vms))
"Tells if Emacs is running under VMS.")
(defvar vip-force-faces nil
"If t, Viper will think that it is running on a display that supports faces.
This is provided as a temporary relief for users of face-capable displays
that Viper doesn't know about.")
(defun vip-has-face-support-p ()
(cond ((vip-window-display-p))
(vip-force-faces)
(vip-emacs-p (memq (vip-device-type) '(pc)))
(vip-xemacs-p (memq (vip-device-type) '(tty pc)))))
;;; Macros
(defmacro vip-deflocalvar (var default-value &optional documentation)
(` (progn
(defvar (, var) (, default-value)
(, (format "%s\n\(buffer local\)" documentation)))
(make-variable-buffer-local '(, var))
)))
(defmacro vip-loop (count body)
"(vip-loop COUNT BODY) Execute BODY COUNT times."
(list 'let (list (list 'count count))
(list 'while '(> count 0)
body
'(setq count (1- count))
)))
(defmacro vip-buffer-live-p (buf)
(` (and (, buf) (get-buffer (, buf)) (buffer-name (get-buffer (, buf))))))
;; return buffer-specific macro definition, given a full macro definition
(defmacro vip-kbd-buf-alist (macro-elt)
(` (nth 1 (, macro-elt))))
;; get a pair: (curr-buffer . macro-definition)
(defmacro vip-kbd-buf-pair (macro-elt)
(` (assoc (buffer-name) (vip-kbd-buf-alist (, macro-elt)))))
;; get macro definition for current buffer
(defmacro vip-kbd-buf-definition (macro-elt)
(` (cdr (vip-kbd-buf-pair (, macro-elt)))))
;; return mode-specific macro definitions, given a full macro definition
(defmacro vip-kbd-mode-alist (macro-elt)
(` (nth 2 (, macro-elt))))
;; get a pair: (major-mode . macro-definition)
(defmacro vip-kbd-mode-pair (macro-elt)
(` (assoc major-mode (vip-kbd-mode-alist (, macro-elt)))))
;; get macro definition for the current major mode
(defmacro vip-kbd-mode-definition (macro-elt)
(` (cdr (vip-kbd-mode-pair (, macro-elt)))))
;; return global macro definition, given a full macro definition
(defmacro vip-kbd-global-pair (macro-elt)
(` (nth 3 (, macro-elt))))
;; get global macro definition from an elt of macro-alist
(defmacro vip-kbd-global-definition (macro-elt)
(` (cdr (vip-kbd-global-pair (, macro-elt)))))
;; last elt of a sequence
(defsubst vip-seq-last-elt (seq)
(elt seq (1- (length seq))))
;; Check if arg is a valid character for register
;; TYPE is a list that can contain `letter', `Letter', and `digit'.
;; Letter means lowercase letters, Letter means uppercase letters, and
;; digit means digits from 1 to 9.
;; If TYPE is nil, then down/uppercase letters and digits are allowed.
(defun vip-valid-register (reg &optional type)
(or type (setq type '(letter Letter digit)))
(or (if (memq 'letter type)
(and (<= ?a reg) (<= reg ?z)))
(if (memq 'digit type)
(and (<= ?1 reg) (<= reg ?9)))
(if (memq 'Letter type)
(and (<= ?A reg) (<= reg ?Z)))
))
;; checks if object is a marker, has a buffer, and points to within that buffer
(defun vip-valid-marker (marker)
(if (and (markerp marker) (marker-buffer marker))
(let ((buf (marker-buffer marker))
(pos (marker-position marker)))
(save-excursion
(set-buffer buf)
(and (<= pos (point-max)) (<= (point-min) pos))))))
(defvar vip-minibuffer-overlay-priority 300)
(defvar vip-replace-overlay-priority 400)
(defvar vip-search-overlay-priority 500)
;;; XEmacs support
(if vip-xemacs-p
(progn
(fset 'vip-read-event (symbol-function 'next-command-event))
(fset 'vip-make-overlay (symbol-function 'make-extent))
(fset 'vip-overlay-start (symbol-function 'extent-start-position))
(fset 'vip-overlay-end (symbol-function 'extent-end-position))
(fset 'vip-overlay-put (symbol-function 'set-extent-property))
(fset 'vip-overlay-p (symbol-function 'extentp))
(fset 'vip-overlay-get (symbol-function 'extent-property))
(fset 'vip-move-overlay (symbol-function 'set-extent-endpoints))
(if (vip-window-display-p)
(fset 'vip-iconify (symbol-function 'iconify-frame)))
(cond ((vip-has-face-support-p)
(fset 'vip-get-face (symbol-function 'get-face))
(fset 'vip-color-defined-p
(symbol-function 'valid-color-name-p))
)))
(fset 'vip-read-event (symbol-function 'read-event))
(fset 'vip-make-overlay (symbol-function 'make-overlay))
(fset 'vip-overlay-start (symbol-function 'overlay-start))
(fset 'vip-overlay-end (symbol-function 'overlay-end))
(fset 'vip-overlay-put (symbol-function 'overlay-put))
(fset 'vip-overlay-p (symbol-function 'overlayp))
(fset 'vip-overlay-get (symbol-function 'overlay-get))
(fset 'vip-move-overlay (symbol-function 'move-overlay))
(if (vip-window-display-p)
(fset 'vip-iconify (symbol-function 'iconify-or-deiconify-frame)))
(cond ((vip-has-face-support-p)
(fset 'vip-get-face (symbol-function 'internal-get-face))
(fset 'vip-color-defined-p (symbol-function 'x-color-defined-p))
)))
(fset 'vip-characterp
(symbol-function
(if vip-xemacs-p 'characterp 'integerp)))
(defsubst vip-color-display-p ()
(if vip-emacs-p
(x-display-color-p)
(eq (device-class (selected-device)) 'color)))
(defsubst vip-get-cursor-color ()
(if vip-emacs-p
(cdr (assoc 'cursor-color (frame-parameters)))
(color-instance-name (frame-property (selected-frame) 'cursor-color))))
;; OS/2
(cond ((eq (vip-device-type) 'pm)
(fset 'vip-color-defined-p
(function (lambda (color) (assoc color pm-color-alist))))))
;; needed to smooth out the difference between Emacs and XEmacs
(defsubst vip-italicize-face (face)
(if vip-xemacs-p
(make-face-italic face)
(make-face-italic face nil 'noerror)))
;; test if display is color and the colors are defined
(defsubst vip-can-use-colors (&rest color